home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Menus / ftpMenu.tcl < prev    next >
Encoding:
Text File  |  1998-12-22  |  11.7 KB  |  451 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*- (install)
  2. # ###################################################################
  3. #  Alpha - new Tcl folder configuration
  4. # 
  5. #  FILE: "ftpMenu.tcl"
  6. #                                    created: 20/7/96 {6:02:55 pm} 
  7. #                                last update: 22/12/1998 {10:52:51 pm} 
  8. #  
  9. #  Description: 
  10. # 
  11. # ###################################################################
  12. ##
  13.  
  14. alpha::menu ftpMenu 0.1.2 global "•141" {} {ftpMenu} {} uninstall {this-file} \
  15.   help {[editMark [file join $HOME Help "Alpha Manual"] "Ftp Browser" -r]}
  16.  
  17. hook::register savePostHook ftpPostHook
  18.  
  19. proc ftpMenu {} {}
  20.  
  21. proc ftpPostHook {name} {
  22.     global fetched
  23.     if {[info exists fetched($name)]} {
  24.     set specs $fetched($name)
  25.     # backwards compatibility
  26.     if {[lindex $specs 4] == ""} {
  27.         lappend specs "ftp"
  28.         set fetched($name) $specs
  29.     }
  30.     message "Updating '[file tail $name]' on [car $specs]…"
  31.     if {[string length [cadr $specs]]} {
  32.         ftpStore $name [car $specs] "[cadr $specs]/[file tail $name]" [caddr $specs] [cadddr $specs]
  33.     } else {
  34.         ftpStore $name [car $specs] "[file tail $name]" [caddr $specs] [cadddr $specs]
  35.     }
  36.     }
  37. }
  38.  
  39. proc rebuildFtpMenu {} {
  40.     global savedMounts recentMounts ftpMenu useCache
  41.     
  42.     Menu -n $ftpMenu -p ftpMenuProc {
  43.     help
  44.     "(-"
  45.     "<S/ibrowse…"
  46.     "<S/i<IbrowseCurrent…"
  47.     "/nbrowseMounts…"
  48.     "(-"
  49.     addMountPoint…
  50.     makePermanent…
  51.     removeMountPoint…
  52.     saveAsAt…
  53.     "(-"
  54.     useCache
  55.     flushCache
  56.     "(-"
  57.     "createFileset"
  58.     "(-"
  59.     }
  60.     markMenuItem -m $ftpMenu "Use Cache" $useCache
  61.     if {[info exists savedMounts]} {
  62.     foreach m [lsort -ignore [array names savedMounts]] {
  63.         addMenuItem -m -l "b " $ftpMenu $m
  64.     }
  65.     }
  66.     if {[info exists recentMounts]} {
  67.     addMenuItem -m $ftpMenu "(-"
  68.     foreach m [lsort -ignore [array names recentMounts]] {
  69.         addMenuItem -m -l "b " $ftpMenu $m
  70.     }
  71.     }
  72. }
  73.  
  74. if {![info exists useCache]} {set useCache 1}
  75.  
  76. app::registerMultiple ftp [list Arch FTCh] [list •141 •315] rebuildFtpMenu
  77.  
  78. proc mountPoints {} {
  79.     global savedMounts recentMounts
  80.     if {[info exists recentMounts]} {
  81.     if {[info exists savedMounts]} {
  82.         set l [concat [array names recentMounts] [array names savedMounts]]
  83.     } else {
  84.         set l [array names recentMounts]]
  85.     }
  86.     } else {
  87.     set l [array names savedMounts]
  88.     }
  89.     return [lsort $l]
  90. }
  91.  
  92.  
  93.  
  94. proc ftpMenuProc {menu item} {
  95.     global modifiedVars modifiedArrVars savedMounts recentMounts PREFS fetched HOME ftpMenu useCache createFtpType
  96.     switch -- $item {
  97.     help                {
  98.         editMark [file join $HOME Help "Alpha Manual"] "Ftp Browser" -r
  99.     }
  100.     browse                {
  101.         eval ftpBrowse [lrange [getLogin {Browse remote machine:} 0] 0 3]
  102.     }
  103.     browseCurrent        { 
  104.         if {[info exists fetched([win::Current])]} {
  105.         eval ftpBrowse $fetched([win::Current]) 
  106.         } else {
  107.         beep; message "'[win::CurrentTail]' not from remote host."
  108.         }
  109.     }
  110.     browseMounts        {
  111.         set l [mountPoints]
  112.         set res [listpick -p "Mount point:" $l]
  113.         if {[info exists recentMounts($res)]} {
  114.         eval ftpBrowse $recentMounts($res)
  115.         } else {
  116.         eval ftpBrowse $savedMounts($res)
  117.         }
  118.     }
  119.     
  120.     addMountPoint        { addMountPoint }
  121.     makePermanent        { makeMountPermanent }
  122.     createFileset        { newFileset ftp }
  123.     removeMountPoint    {
  124.         set pt [listpick -p "Remove which mount point?" [lsort -ignore [array names savedMounts]]]
  125.         unset savedMounts($pt)
  126.         removeArrDef savedMounts $pt
  127.         rebuildFtpMenu
  128.     }
  129.     saveAsAt            {
  130.         global fetched PREFS
  131.         set name [prompt "Name:" [win::CurrentTail]]
  132.         set point [listpick -p "At which mount point?" [mountPoints]]
  133.         if {[info exists recentMounts($point)]} {
  134.         set specs $recentMounts($point)
  135.         } else {
  136.         set specs $savedMounts($point)
  137.         }
  138.         # backwards compatibility
  139.         if {[lindex $specs 4] == ""} {
  140.         lappend specs "ftp"
  141.         }
  142.         set name [file join $PREFS ftptmp $name]
  143.         set fetched($name) $specs
  144.         message "Saving '$name' on [car $specs]…"
  145.         
  146.         if {![file exists $name]} {
  147.         set fid [open $name w]
  148.         close $fid
  149.         }
  150.         saveAs -f "$name"
  151.         
  152.         set num 0
  153.         set pathname [cadr $specs]
  154.         for {set i [expr [string length $pathname] - 1]} {$i >= 0} {incr i -1} {
  155.         scan $pathname "%c" char
  156.         incr num $char
  157.         }
  158.         
  159.         set nm [file join $PREFS ftptmp listing.$num]
  160.         catch {rm $nm}
  161.         
  162.         setWinInfo platform $createFtpType
  163.         setWinInfo dirty 1
  164.         save
  165.     }
  166.     
  167.     setDefaults            { 
  168.         global ftpDefaults modifiedVars
  169.         set ftpDefaults [lrange [getLogin "Enter defaults that you wish saved:" 0] 0 3]
  170.         lappend modifiedVars ftpDefaults
  171.     }
  172.     flushCache        { rm [file join $PREFS ftptmp *]; catch {unset recentMounts}; rebuildFtpMenu }
  173.     useCache    { 
  174.         set useCache [expr 1 - $useCache]
  175.         markMenuItem -m $ftpMenu "Use Cache" $useCache
  176.         lappend modifiedVars useCache
  177.     }
  178.     default {
  179.         if {[info exists recentMounts($item)]} {
  180.         eval ftpBrowse $recentMounts($item)
  181.         } else {
  182.         eval ftpBrowse $savedMounts($item)
  183.         }
  184.     }
  185.     }
  186. }
  187.  
  188.  
  189. proc ftpFilesetOpen {menu item} {
  190.     global gfileSets PREFS fetched fileSetsExtra
  191.     
  192.     if {[set ind [lsearch $gfileSets($menu) "*$item"]] >= 0} {
  193.     set f [lindex $gfileSets($menu) $ind]
  194.     set lnm [file tail $f]
  195.     regsub -all {:} $f {/} f
  196.     set nm [file join $PREFS ftptmp $lnm]
  197.     set specs $fileSetsExtra($menu)
  198.     # backwards compatibility
  199.     if {[lindex $specs 4] == ""} {
  200.         lappend specs "ftp"
  201.         set fileSetsExtra($menu) $specs
  202.     }
  203.     if {![file exists $nm]} {
  204.         ftpFetch $nm [car $specs] $f [caddr $specs] [cadddr $specs]
  205.     }
  206.     edit -w $nm
  207.     set fetched($nm) $specs
  208.     }
  209. }
  210.  
  211.  
  212. proc ftpCreateFileset {} {
  213.     global gfileSets gfileSetsType PREFS fileSetsExtra
  214.     
  215.     set specs [getLogin]
  216.     set name [car $specs]
  217.     set host [cadr $specs]
  218.     set path [caddr $specs]
  219.     set user [cadddr $specs]
  220.     set password [caddddr $specs]
  221.     set pattern "^[prompt {Name pattern?} {.*.[ch]}]$"
  222.     set path [string trimright $path {/}]
  223.     
  224.     set fileSetsExtra($name) [list $host $path $user $password "ftp"]
  225.     
  226.     if { ![file exists [file join $PREFS ftptmp]] } {
  227.     file mkdir [file join $PREFS ftptmp]
  228.     }
  229.     set nm [file join $PREFS ftptmp listing.$path]
  230.     ftpList $nm $host $path $user $password
  231.     set files {}
  232.     foreach f [processListing $nm] {
  233.     if {![string match {*/} $f] && [regexp $pattern $f]} {
  234.         lappend files "$path/$f"
  235.     }
  236.     }
  237.     regsub -all {/} $files {:} files
  238.     
  239.     global gfileSets gfileSetsType
  240.     set gfileSets($name) [lsort -command sortByTail $files]
  241.     set gfileSetsType($name) ftp
  242.     if {[askyesno "Save project fileset?"] == "yes"} {
  243.     addArrDef gfileSetsType $name ftp
  244.     addArrDef gfileSets $name  $gfileSets($name)
  245.     addArrDef fileSetsExtra $name $fileSetsExtra($name)
  246.     }
  247.     return $name
  248. }
  249.  
  250.  
  251. proc processListing {path} {
  252.     set fd [open $path "r"]
  253.     set lines [split [read $fd] "\n"]
  254.     close $fd
  255.     set files {}
  256.     if {[llength $lines]} {
  257.     if {[string length [lindex $lines 0]] <= 10} {
  258.         set lines [cdr [lreplace $lines end end]]
  259.     } else {
  260.         set lines [lreplace $lines end end]
  261.     }
  262.     foreach f $lines {
  263.         regexp {[A-Z][a-z]+ [0-9, ]+ [0-9,:]+ (.*)$} $f dummy nm
  264.         if {[string length $nm]} {
  265.         if {[string match "d*" $f]} {
  266.             if {![string match "." $nm] && ![string match ".." $nm]} {
  267.             lappend files "$nm/"
  268.             }
  269.         } else {
  270.             lappend files $nm
  271.         }
  272.         }
  273.     }
  274.     } else {
  275.     error "empty list"
  276.     }
  277.     return $files
  278. }
  279.  
  280. proc getLogin {{prompt {All but 'password' are required:}} {nm 1}} {
  281.     global ftpDefaults
  282.     if {[info exists ftpDefaults]} {
  283.     set defs $ftpDefaults
  284.     } else {
  285.     set defs {"" "" "" ""}
  286.     }
  287.     set left 10
  288.     set right 100
  289.     set top 10
  290.     set bottom 30
  291.     set eleft [expr $left + 100]
  292.     set eright 370
  293.     set incr 30
  294.     
  295.     set height 198
  296.     
  297.     if $nm {incr height $incr}
  298.     set l "dialog -w 400 -h $height -t [list $prompt] $left $top 400 $bottom"
  299.     
  300.     if {$nm} {
  301.     incr top $incr
  302.     incr bottom $incr
  303.     lappend l -t {Name:} $left $top $right $bottom
  304.     lappend l -e {} $eleft $top $eright $bottom
  305.     }
  306.     
  307.     incr top $incr
  308.     incr bottom $incr
  309.     lappend l -t {Host:} $left $top $right $bottom
  310.     lappend l -e [car $defs] $eleft $top $eright $bottom
  311.     
  312.     incr top $incr
  313.     incr bottom $incr
  314.     lappend l -t {Path:} $left $top $right $bottom
  315.     lappend l -e [cadr $defs] $eleft $top $eright $bottom
  316.     
  317.     incr top $incr
  318.     incr bottom $incr
  319.     lappend l -t {UserID:} $left $top $right $bottom
  320.     lappend l -e [caddr $defs] $eleft $top $eright $bottom
  321.     
  322.     incr top $incr
  323.     incr bottom $incr
  324.     lappend l -t {Password:} $left $top $right $bottom
  325.     lappend l -e [cadddr $defs] $eleft [expr $top + 6] $eright [expr $bottom - 12]
  326.     
  327.     incr top [expr $incr + 10]
  328.     incr bottom [expr $incr + 10]
  329.     lappend l -b "OK" $left $top $right [expr $top + 20]
  330.     lappend l -b "Cancel" [expr $left + 200] $top [expr $right + 200] [expr $top + 20]
  331.     
  332.     set res [eval "$l"]
  333.     if {[lindex $res end]} {error "Cancel"}
  334.     return $res
  335. }
  336.  
  337.  
  338. proc addMountPoint {} {
  339.     global savedMounts modifiedArrVars
  340.     
  341.     set res [getLogin]
  342.     if {[lindex $res 5]} {
  343.     set savedMounts([car $res]) [concat [lrange $res 1 4] "ftp"]
  344.     lappend modifiedArrVars savedMounts
  345.     rebuildFtpMenu
  346.     }
  347. }
  348.  
  349.  
  350. proc makeMountPermanent {} {
  351.     global recentMounts savedMounts modifiedArrVars
  352.     if {![info exists recentMounts]} {
  353.     alertnote "You have no temporary mounts."
  354.     return
  355.     }
  356.     set res [listpick -p "Make which temporary mount point permanent?" [lsort [array names recentMounts]]]
  357.     set name [prompt "Name?" $res]
  358.     set savedMounts($name) $recentMounts($res)
  359.     unset recentMounts($res)
  360.     lappend modifiedArrVars savedMounts
  361.     rebuildFtpMenu
  362. }
  363.  
  364.  
  365. proc ftpPromptBrowse {} {
  366.     eval ftpBrowse [lrange [getLogin {Browse remote machine:} 0] 0 3]
  367. }
  368.  
  369. proc ftpBrowse {host dir user password {type "ftp"} {fname {}}} {
  370.     global PREFS fetched lastFtpDir recentMounts savedMounts useCache
  371.     
  372.     watchCursor
  373.     if {![string length $password]} {
  374.     set password [dialog::password "Password for ${host}:"]
  375.     }
  376.     
  377.     if {![file exists [file join $PREFS ftptmp]]} {
  378.     file mkdir [file join $PREFS ftptmp]
  379.     }
  380.     if {$dir == {-}} {
  381.     if {![info exists lastFtpDir] || ![string length $lastFtpDir]} {set lastFtpDir ""}
  382.     set dir [prompt "'$host' dir:" $lastFtpDir]
  383.     }
  384.     set dir [string trimright $dir {/}]
  385.     set lastFtpDir $dir
  386.     
  387.     set num 0
  388.     for {set i [expr [string length $dir] - 1]} {$i >= 0} {incr i -1} {
  389.     scan [string index $dir $i] "%c" char
  390.     incr num $char
  391.     }
  392.     
  393.     set nm [file join $PREFS ftptmp listing.$num]
  394.     
  395.     if {!$useCache || ![file exists $nm]} {
  396.     ftpList $nm $host $dir $user $password
  397.     }
  398.     if {[catch {processListing $nm} listing]} {
  399.     alertnote "Error fetching directory '$dir'"
  400.     error "Error fetching directory '$dir'"
  401.     }
  402.     set files [concat {..} $listing]
  403.     if {$fname != ""} {
  404.     set file [listpick -L $fname -p "$dir/" $files]
  405.     } else {
  406.     set file [listpick -p "$dir/" $files]
  407.     }
  408.     
  409.     if {$file == {..}} {
  410.     if {[regexp {(.+)/[^/]+} $dir dummy sub]} {
  411.         return [ftpBrowse $host $sub $user $password]
  412.     } else {
  413.         return [ftpBrowse $host "" $user $password]
  414.     }
  415.     }
  416.     
  417.     if {[string match {*/} $file]} {
  418.     if {[string length $dir]} {
  419.         return [ftpBrowse $host [string trimright "$dir/$file" {/}] $user $password]
  420.     } else {
  421.         return [ftpBrowse $host [string trimright "$file" {/}] $user $password]
  422.     }
  423.     }
  424.     
  425.     set entry [list $host $dir $user $password $type]
  426.     set new 1
  427.     foreach name [array names savedMounts] {
  428.     if {([car $savedMounts($name)] == [car $entry]) && ([cadr $savedMounts($name)] == [cadr $entry])} {
  429.         set new 0
  430.         break;
  431.     }
  432.     }
  433.     if $new {
  434.     set recentMounts($dir) $entry
  435.     rebuildFtpMenu
  436.     }
  437.     
  438.     set nm [file join $PREFS ftptmp $file]
  439.     if {!$useCache || ![file exists $nm]} {
  440.     if {[string length $dir]} {
  441.         ftpFetch $nm $host "$dir/$file" $user $password
  442.     } else {
  443.         ftpFetch $nm $host "$file" $user $password
  444.     }
  445.     }
  446.     edit -w $nm
  447.     set fetched($nm) [list $host $dir $user $password "ftp"]
  448. }
  449.  
  450.  
  451.